home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / keymap.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  5KB  |  144 lines
  1. ;;;; keymap.jl -- extra functions for handling keymaps
  2. ;;;  Copyright (C) 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'keymap)
  21.  
  22. ;;;###autoload
  23. (defun print-keymap (&optional keymap-list buffer)
  24.   "Prints a description of the installed keymaps in the current buffer."
  25.   (unless keymap-list
  26.     (setq keymap-list keymap-path))
  27.   (unless buffer
  28.     (setq buffer (current-buffer)))
  29.   (insert "\nKey/Event")
  30.   (indent-to 24)
  31.   (insert "Binding\n---------")
  32.   (indent-to 24)
  33.   (insert "-------\n\n")
  34.   (let
  35.       (done-list)            ; keymaps already printed
  36.     (while keymap-list
  37.       (let
  38.       ((keymap (car keymap-list))
  39.        km-prefix-string)
  40.     (setq keymap-list (cdr keymap-list))
  41.     (when (and (not (keymapp keymap)) (consp keymap))
  42.       (setq km-prefix-string (cdr keymap)
  43.         keymap (car keymap)))
  44.     (unless (memq keymap done-list)
  45.       (setq done-list (cons keymap done-list))
  46.       (when (symbolp keymap)
  47.         (format (current-buffer) " -- %s:\n" keymap)
  48.         (setq keymap (with-buffer buffer (symbol-value keymap))))
  49.       (when (keymapp keymap)
  50.         (cond
  51.          ((vectorp keymap)
  52.           (let
  53.           ((i (length keymap)))
  54.         (while (>= i 0)
  55.           (km-print-list (aref keymap i))
  56.           (setq i (1- i)))))
  57.          (t
  58.           (km-print-list (cdr keymap)))))
  59.       (insert "\n"))))))
  60.  
  61. ;; Print one keymap. This accesses the free variables `keymap-list' and
  62. ;; `km-prefix-string' -- both in describe-keymap.
  63. (defun km-print-list (keymap)
  64.   (let
  65.       (key cmd event-str)
  66.     (while keymap
  67.       (setq key (car keymap)
  68.         cmd (aref key 2)
  69.         event-str (event-name (cons (aref key 0) (aref key 1))))
  70.       (when (and (eq (car cmd) 'setq) (eq (nth 1 cmd) 'next-keymap-path))
  71.     ;; Link to another keymap; add it to the list of keymaps to
  72.     ;; examine later.
  73.     (let*
  74.         ((new-str (concat km-prefix-string (if km-prefix-string ?\ )
  75.                   event-str))
  76.          (new-list (mapcar #'(lambda (km)
  77.                    (cons km new-str))
  78.                    (eval (nth 2 cmd)))))
  79.       (setq keymap-list (append keymap-list new-list))))
  80.       (insert (concat km-prefix-string (if km-prefix-string ?\ )  event-str))
  81.       (indent-to 24)
  82.       (prin1 cmd (current-buffer))
  83.       (insert "\n")
  84.       (setq keymap (cdr keymap)))))
  85.  
  86.  
  87. ;; Get one event
  88.  
  89. (defun km-read-event-fun ()
  90.   (throw 'read-event (current-event)))
  91.  
  92. ;;;###autoload
  93. (defun read-event (&optional title)
  94.   "Read the next event and return a cons cell containing the two integers that
  95. define that event."
  96.   (let
  97.       ((buffer (current-buffer))
  98.        (old-kp keymap-path)
  99.        (old-nkp next-keymap-path))
  100.     (setq keymap-path nil
  101.       next-keymap-path nil
  102.       status-line-cursor t)
  103.     (add-hook 'unbound-key-hook 'km-read-event-fun)
  104.     (unwind-protect
  105.     (catch 'read-event
  106.       (message (or title "Type a key:"))
  107.       (recursive-edit))
  108.       (with-buffer buffer
  109.     (remove-hook 'unbound-key-hook 'km-read-event-fun)
  110.     (setq keymap-path old-kp
  111.           next-keymap-path old-nkp
  112.           status-line-cursor nil)))))
  113.  
  114. ;;;###autoload
  115. (defun describe-key ()
  116.   "Read an event sequence from the user then display details of the command it
  117. would invoke."
  118.   (interactive)
  119.   (let
  120.       (names event command done)
  121.     (while (not done)
  122.       (setq event (read-event (concat "Enter a key sequence: " names))
  123.         names (concat names (if names ?\ )
  124.               (event-name event)))
  125.       (if (setq command (lookup-event-binding event t))
  126.       (if (and (eq (car command) 'setq)
  127.            (eq (nth 1 command) 'next-keymap-path))
  128.           ;; A link to another keymap
  129.           (call-command command)
  130.         ;; End of the chain
  131.         (require 'help)
  132.         (help-setup)
  133.         (format (current-buffer) "\n%s -> %S\n" names command)
  134.         (when (functionp command)
  135.           (format (current-buffer)
  136.               "\n%s\n"
  137.               (or (documentation command) "")))
  138.         (goto-buffer-start)
  139.         (setq done t))
  140.     (message (concat names " is unbound. "))
  141.     (setq done t
  142.           next-keymap-path nil)))))
  143.  
  144.